MacFormat 1994 December/macformat-019.iso/Reader's Corner/Reader's Contibutions/MgM Collection/LeapYear1.5.1 ƒ/LeapYear1.5.1p

Text File | 1994-05-09 | 7.9 KB | 404 lines | [TEXT/PJMM]

PROGRAM LeapYear1;

USES
    sound;
CONST
    rLEAP = 128;
    rABOUT = 129;
    rBINARY = 130;
    rABOUT2 = 131;

    iCALC = 1;
    iINYEAR = 2;
    iBCALC = 5;

    mAPPLE = 128;
    mFILE = 129;

    sMOMMA = 128;
    sYOUAINT = 129;
    sHAHA = 130;
    sWRETCHED = 131;

VAR
    wpMAIN, wpBINARY, anyWINDOW: windowptr;
    dpMAIN, dpBINARY: dialogptr;
    myMENU: ARRAY[1..2] OF menuhandle;
    myEVENT: eventrecord;
    mask, item, x: integer;
    endIT: boolean;
    thechar: char;
    BINstr: PACKED ARRAY[1..25] OF char;
    err: oserr;

FUNCTION soundme (sndrsrc: integer): oserr;

    BEGIN
        soundme := sndplay(NIL, getresource(soundListRsrc, sndrsrc), false);
    END;

FUNCTION GetIRect (d: DialogPtr;
                                item: Integer): RectPtr;
    VAR
        iType: Integer;
        iHdl: Handle;
        itemrect: rect;

    BEGIN
        GetDItem(d, item, iType, iHdl, itemRect);
        GetIRect := @itemRect;
    END;

PROCEDURE expand (dlog: dialogptr);
    TYPE
        Quadrant = (One, Two, Three, Four);
    VAR

        Quarters: ARRAY[Quadrant] OF Rect;
        quad: Quadrant;
        tix: LongInt;
        savePort: GrafPtr;
        updRgn: RgnHandle;
        hPos, hHalf, vHalf, iType, item: Integer;
        r: Rect;
        iHdl: Handle;
        pic: PicHandle;
        e: eventrecord;
    CONST
        SlideOffset = 3;

    BEGIN
        GetPort(savePort);
        SetPort(dlog);
        WHILE NOT GetNextEvent(mDownMask, e) DO
            ;
        WHILE WaitMouseUp DO
            ;
        r := GetIRect(dlog, 1)^;
        FOR quad := One TO Four DO
            Quarters[quad] := r;
        WITH r DO
            BEGIN
                vHalf := (bottom + top) DIV 2;
                hHalf := (left + right) DIV 2;
            END;

        Quarters[One].bottom := vHalf;
        Quarters[One].left := hHalf;

        Quarters[Two].top := vHalf;
        Quarters[Two].left := hHalf;

        Quarters[Three].top := vHalf;
        Quarters[Three].right := hHalf;

        Quarters[Four].bottom := vHalf;
        Quarters[Four].right := hHalf;

        updRgn := NewRgn;
        hPos := vHalf;

        WHILE (hPos > 0) DO
            BEGIN
                ObscureCursor;

                hPos := hPos - SlideOffset;
                ScrollRect(Quarters[one], SlideOffset, -SlideOffset, updRgn);
                ScrollRect(Quarters[two], SlideOffset, SlideOffset, updRgn);
                ScrollRect(Quarters[three], -SlideOffset, SlideOffset, updRgn);
                ScrollRect(Quarters[four], -SlideOffset, -SlideOffset, updRgn);

                Delay(1, tix);
            END;

        DisposeRgn(updRgn);
        DisposDialog(dlog);
        ReleaseResource(Handle(pic));
        SetPort(savePort);
    END;

PROCEDURE integerof (thestring: STRING;
                                VAR thenumb: integer;
                                maxlen: integer);
    VAR
        i, L: integer;
        digit: boolean;
    BEGIN
        thenumb := 0;
        i := 0;
        l := length(thestring);
        IF L > maxlen THEN
            BEGIN
                thenumb := -2;
                exit(integerof);
            END;
        REPEAT
            i := i + 1;
            digit := thestring[i] IN ['0'..'9'];
            thenumb := 10 * thenumb + (ord(thestring[i]) - ord('0'));
        UNTIL (i = l) OR NOT digit;
        IF NOT digit THEN
            thenumb := -1;
    END;

FUNCTION leapyr (year: integer): boolean;
    BEGIN
        leapyr := (year MOD 4 = 0) AND (year MOD 100 <> 0) OR (year MOD 400 = 0);
    END;

PROCEDURE calcLEAP;
    VAR
        YEAR: INTEGER;
        thestr: str255;
        itype, itypeb, itypec: integer;
        it, itb, itc: handle;
        box, boxb, boxc: rect;
    BEGIN
        getditem(dpMAIN, iINYEAR, itype, it, box);
        getitext(it, thestr);
        integerof(stringof(thestr), year, 4);
        getditem(dpMAIN, 3, itypeb, itb, boxb);
        getditem(dpMAIN, 6, itypec, itc, boxc);
        CASE year OF
            -1:
                BEGIN
                    setitext(itb, 'N/A');
                    setitext(itc, 'Please try again.');
                    err := soundme(sWRETCHED);
                END;
            -2:
                BEGIN
                    setitext(itb, 'N/A');
                    setitext(itc, 'Please try again.');
                    err := soundme(sWRETCHED);
                END;
            OTHERWISE
                BEGIN
                    IF leapyr(year) THEN
                        BEGIN
                            setitext(itb, 'Leap year.');
                            setitext(itc, '');
                        END
                    ELSE
                        BEGIN
                            setitext(itb, 'Not a Leap year.');
                            setitext(itc, '');
                        END;
                END;

        END;
        drawdialog(dpMAIN);
    END;

PROCEDURE writebinary (n: longint);
    CONST
        base = 2;
    BEGIN

        IF n >= base THEN
            writebinary(n DIV base);
        BEGIN
            x := x + 1;
            binstr[x] := stringof(n MOD base : 1);

        END;
    END;

PROCEDURE CalcBINARY;
    VAR
        BINARY: INTeger;
        thestr, BINbSTR: str255;
        itype, itypeb, itypec, y: integer;
        it, itb, itc: handle;
        box, boxb, boxc: rect;
    BEGIN
        x := 1;
        FOR y := 1 TO 25 DO
            BINstr[y] := ' ';
        x := 0;
        getditem(dpBINARY, iINYEAR, itype, it, box);
        getitext(it, thestr);
        getditem(dpBINARY, 6, itypeb, itb, boxb);
        getditem(dpBINARY, 4, itypec, itc, boxc);
        integerof(stringof(thestr), BINARY, 8);
        CASE BINARY OF
            -1:
                BEGIN
                    setitext(itb, 'N/A');
                    setitext(itc, 'Please try again.');
                    err := soundme(sWRETCHED);
                END;
            -2:
                BEGIN
                    setitext(itb, 'N/A');
                    setitext(itc, 'Please try again.');
                    err := soundme(sWRETCHED);
                END;
            OTHERWISE
                BEGIN
                    writebinary(BINARY);
                    BINbSTR := stringof(BINstr);
                    setitext(itb, BINbSTR);
                    setitext(itc, '');
                END;

        END;
        drawdialog(dpBINARY);
    END;

PROCEDURE DoAbout;
    VAR
        about: dialogptr;
        e: eventrecord;
    BEGIN
        Hilitewindow(wpMain, false);

        about := GetNewDialog(rABOUT, NIL, Windowptr(-1));
        drawdialog(about);
        err := soundme(sYOUAINT);
        expand(about);

        about := GetNewDialog(rABOUT2, NIL, Windowptr(-1));
        drawdialog(about);
        err := soundme(sMOMMA);
        expand(about);

        Hilitewindow(wpMain, true);
    END;

PROCEDURE DoMenu (mresult: longint);
    VAR
        theitem, themenu: integer;
        name: str255;
        temp: integer;
    BEGIN
        theitem := loword(mresult);
        themenu := hiword(mresult);
        CASE themenu OF
            mAPPLE:
                BEGIN
                    IF theitem = 1 THEN
                        DoAbout
                    ELSE
                        BEGIN
                            getitem(myMENU[1], theitem, name);
                            temp := opendeskacc(name);
                            setport(dpMAIN);
                        END;
                END;
            mFILE:
                BEGIN
                    CASE theitem OF
                        1:
                            BEGIN
                                Hilitewindow(wpMain, true);
                                bringtofront(dpMAIN);
                                showwindow(dpMain);
                                Hilitewindow(wpBINARY, false);

                            END;
                        2:
                            BEGIN
                                Hilitewindow(wpBINARY, true);
                                bringtofront(dpBINARY);
                                showwindow(dpBINARY);
                                Hilitewindow(wpMain, false);
                            END;
                        4:
                            endit := true;
                    END;
                END;
        END;
        hilitemenu(0);
    END;

PROCEDURE SETMEUP;

    BEGIN
        initcursor;
        initmenus;
        x := 0;

        myMENU[1] := getmenu(mAPPLE);
        addresmenu(myMENU[1], 'DRVR');
        insertmenu(myMENU[1], 0);
        myMENU[2] := getmenu(mFILE);
        insertmenu(myMENU[2], 0);
        drawmenubar;

        dpBINARY := GetNewDialog(rBINARY, NIL, WindowPtr(-1));
        wpBINARY := dpBINARY;
        hidewindow(dpBINARY);
        paramtext('', '', '', '');

        dpMAIN := GetNewDialog(rLEAP, NIL, WindowPtr(-1));
        wpMAIN := dpMAIN;
        paramtext('', '', '', '');
        endIT := False;
    END;

BEGIN
    setmeup;
    REPEAT
        systemtask;
        IF getnextevent(-1, myEVENT) OR isdialogevent(myEVENT) THEN
            BEGIN
                mask := findwindow(myEVENT.where, anyWINDOW);
                CASE myEVENT.what OF
                    1:
                        BEGIN
                            CASE mask OF
                                indrag:
                                    BEGIN
                                        IF anywindow <> frontwindow THEN
                                            selectwindow(anyWINDOW);
                                        dragwindow(anyWINDOW, myEVENT.where, screenbits.bounds);
                                    END;
                                incontent:
                                    BEGIN
                                        IF anywindow <> frontwindow THEN
                                            selectwindow(anyWINDOW);
                                    END;
                                indesk:
                                    Hilitewindow(wpMain, false);
                                insyswindow:
                                    systemclick(myEVENT, anyWINDOW);
                                inmenubar:
                                    DoMenu(menuselect(myEVENT.where));
                                ingoaway:
                                    BEGIN
                                        IF TrackGoAway(anyWINDOW, myEVENT.where) THEN
                                            hidewindow(anywindow);
                                    END;
                            END;
                        END;
                    activateevt:
                        BEGIN
                            IF bitand(myEVENT.modifiers, activeflag) <> 0 THEN
                            ELSE
                        END;
                    keydown, autokey:
                        BEGIN
                            thechar := chr(bitand(myEVENT.message, charcodemask));
                            IF bitand(myEVENT.modifiers, cmdkey) <> 0 THEN
                                domenu(menukey(thechar));
                        END;
                END;
                IF dialogselect(myEVENT, anyWINDOW, item) THEN
                    IF anyWINDOW = dpMAIN THEN
                        BEGIN
                            IF item = iCALC THEN
                                calcLEAP;
                        END
                    ELSE IF anyWINDOW = dpBINARY THEN
                        BEGIN
                            IF item = iBCALC THEN
                                calcBINARY;
                        END;
            END;

    UNTIL endIT;
    closedialog(dpMAIN);
    closedialog(dpBINARY);
    err := soundme(sHAHA);
END.